home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CD ROM Paradise Collection 4
/
CD ROM Paradise Collection 4 1995 Nov.iso
/
program
/
jx4nt123.zip
/
JX4FILES.A
< prev
next >
Wrap
Text File
|
1994-09-05
|
30KB
|
967 lines
; jx4files.a ... File-Access wordset words for Jax4th 32-bit ANS Forth for Windows NT
; copyright (c) 1993, 1994 by jack j. woehr
; p.o. box 51, golden, co 80402-0051
; jax@well.sf.ca.us | JAX on GEnie | 72203.1320@compuserve.com
; sysop, rcfb (303) 278-0364
COMMENT !
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details. (doc\license.txt)
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
!
;
; $Log: jx4files.a,v $
; Revision 1.9 1994/08/21 07:35:12 jax
; Fixed OPEN-FILE to do its own null padding.
;
; Revision 1.9 1994/08/21 07:35:12 jax
; Fixed OPEN-FILE to do its own null padding.
;
; Revision 1.8 1994/08/20 09:27:14 jax
; Added INCLUDED.
; Fixed CREATE-FILE to do its own null appending.
;
; Revision 1.7 1994/08/20 05:51:03 jax
; added INCLUDE-FILE
;
; Revision 1.6 1994/08/04 02:02:24 jax
; Added READ-LINE. Moved the A and W words to NONSTANDARD-WORDLIST.
;
; Revision 1.5 1994/07/28 18:26:23 jax
; Changed all the file words so that they have both ascii and
; unicode versions, with a deferred top-level word init'ed
; by COLD at powerup.
;
; Revision 1.4 1994/07/18 07:05:57 jax
; Worked on READ-LINE, didn't finish.
;
; Revision 1.3 1994/06/13 22:40:54 jax
; masm 6.11 protos
;
; Revision 1.2 1994/05/21 06:25:03 jax
; Changed copyright dates.
;
; Revision 1.1 1993/12/29 21:06:34 jax
; Initial revision
;
fnamemanque <CLOSE-FILE> ; fileid -- ior ( == system error if failure, == 0 if success)
fw_CLOSEFILE: ; FILE
docode
call CloseHandle
and eax,eax ; indicates success, but we reverse the code
jne closefile1
INVOKE GetLastError ; get error
push eax ; push error ior
store lastError,eax ; to be consistent with rest of system
next
closefile1:
xor eax,eax
push eax ; success
next
fnamemanque <CREATE-FILE> ; c-addr u x1 -- x2 ior (== 0 | system err)
fw_CREATEFILE: ; FILE
ctok NEST
ctok TO_R ; -- c-addr u R: -- x1
ctok CHARS
ctok TUCK ; -- u' c-addr u' R: -- x1
literal zeroBuffer ; -- u' c-addr1 u' c-addr2 R: -- x1
ctok SWAP ; -- u' c-addr1 c-addr2 u' R: -- x1
ctok MOVE ; -- u' R: -- x1
literal zeroBuffer ; -- u' c-addr R: -- x1
ctok OVER ; -- u' c-addr u' R: -- x1
ctok PLUS ; -- u' c-addr' R: -- x1
literal 0 ; -- u' c-addr' 0 R: -- x1
ctok SWAP ; -- u' 0 c-addr' R: -- x1
ctok C_STORE ; -- u' R: --
literal zeroBuffer ; -- u' c-addr R: -- x1
ctok SWAP ; -- c-addr u' R: -- x1
ctok R_FROM ; -- c-addr u' x1 R: --
ctok CREATFILE ; -- x2 ior
ctok UNNEST
zname <CREATFILE> ; c-addr u x1 -- x2 ior (== 0 | system err)
docode
pop eax ; x1
pop ecx ; u
pop edx ; c-addr
add edx,dp ; abs-addr
INVOKE CreateFileW, edx, eax, 0, OFFSET FLAT:secAttrib, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0
push eax ; push resultant handle
cmp eax,INVALID_HANDLE_VALUE
jne createfile1 ; if handle is invalid, we don't branch
INVOKE GetLastError ; get error
push eax ; push error ior
store lastError,eax ; to be consistent with rest of system
next
createfile1:
xor eax,eax
push eax ; success, ior is zero
next
fnamemanque <DELETE-FILE> ; c-addr u -- ior (== 0 | system err)
fw_DELETEFILE: ; FILE
docode
pop edx ; u
pop eax ; c-addr
add eax,dp ; abs-addr
INVOKE DeleteFileW, eax
and eax,eax
je deletefile1 ; if zero, we failed
xor eax,eax ; but our Forth result for success is zero (0)
push eax ; success
next
deletefile1:
INVOKE GetLastError ; failure, get system error code
push eax ; push error ior
store lastError,eax ; to be consistent with rest of system
next
nname <FERROR> ; -- a-addr
ctok DOCONST ; CORE
dd var_ferror
fnamemanque <FILE-POSITION>
; fileid -- ud ior (0= success , nz== last error
fw_FILEPOSITION: ; FILE
defers
nnamemanque <FILE-POSITIONW>
; fileid -- ud-chars ior (0= success , nz== last error
fw_FILEPOSITIONW: ; FILE
ctok NEST
ctok FILEPOSITIONA ; -- ud-bytes ior
ctok TO_R ; -- ud-bytes R: -- ior
literal tchar
ctok DUMSLMOD ; -- modulus ud-chars R: -- ior
ctok ROT ; -- ud-chars modulus R: -- ior
ctok DROP ; -- ud-chars R: -- ior
ctok R_FROM ; -- ud-chars ior R: --
ctok UNNEST
nnamemanque <FILE-POSITIONA>
; fileid -- ud=-bytes ior (0= success , nz== last error
fw_FILEPOSITIONA: ; FILE
docode
pop edx ; fileid
mov DWORD PTR distMoveHigh,0 ; hi word of dist to move
INVOKE SetFilePointer, edx, 0, OFFSET FLAT:distMoveHigh, FILE_CURRENT
cmp eax,-1 ; if -1, must check distMoveHigh
jne filepos1
cmp DWORD PTR distMoveHigh,0 ; if zero, we have an err
jne filepos1 ; not zero is success
INVOKE GetLastError ; get error
push 0
push 0 ; ud
push eax ; push error ior
store lastError,eax ; to be consistent with rest of system
next
filepos1:
push eax
push DWORD PTR distMoveHigh
push 0 ; success, ior is zero
next
fnamemanque <FILE-SIZE> ; fileid -- ud ior
fw_FILESIZE: ; FILE
defers
nnamemanque <FILE-SIZEW> ; fileid -- ud-chars ior
fw_FILESIZEW: ; FILE
ctok NEST
ctok FILESIZEA ; -- ud-bytes ior
ctok TO_R ; -- ud-bytes R: -- ior
literal tchar ; -- ud-bytes u R: -- ior
ctok DUMSLMOD ; -- mod ud-chars R: -- ior
ctok ROT ; -- ud-chars mod R: -- ior
ctok DROP ; -- ud-chars R: -- ior
ctok R_FROM ; -- ud-chars ior R: --
ctok UNNEST
nnamemanque <FILE-SIZEA> ; fileid -- ud-bytes ior
fw_FILESIZEA: ; FILE
docode
pop eax
INVOKE GetFileInformationByHandle, eax, OFFSET FLAT:fileInfo
cmp eax,0
jne filesize1 ; if handle is invalid, we don't branch
INVOKE GetLastError ; get error
push 0
push 0 ; ud
push eax ; push error ior
store lastError,eax ; to be consistent with rest of system
next
filesize1:
push DWORD PTR fileInfo.nFileSizeLow
push DWORD PTR fileInfo.nFileSizeHigh
xor eax,eax
push eax ; success, ior is zero
next
fnamemanque <INCLUDE-FILE> ; i*x fileid -- j*x
fw_INCLUDEFILE: ; FILE
ctok NEST
ctok TIB
ctok TO_R ; -- i*x fileid R: -- 'TIB
ctok NUMTIB
ctok FETCH
ctok TO_R ; -- i*x fileid R: -- 'TIB #TIB
ctok TO_IN
ctok FETCH
ctok TO_R ; -- i*x fileid R: -- 'TIB #TIB >IN
ctok SOURCE_ID
ctok FETCH
ctok TO_R ; -- i*x fileid R: -- 'TIB #TIB >IN SOURCE-ID
ctok BLK
ctok FETCH
ctok TO_R ; -- i*x fileid R: -- 'TIB #TIB >IN SOURCE-ID BLK
literal endq
ctok FETCH
ctok TO_R ; -- i*x fileid R: -- 'TIB #TIB >IN SOURCE-ID BLK endq
ctok SOURCE_ID ; -- i*x fileid a-addr R: -- 'TIB #TIB >IN SOURCE-ID BLK endq
ctok STORE ; -- i*x R: -- x x x x x x
incfileloop: ; -- i*x R: -- x x x x x x
literal tickftib
literal tibsize
ctok SOURCE_ID
ctok FETCH
ctok READLINE ; -- i*x u flag ior R: -- x x x x x x
ctok QDUP ; -- i*x u flag ior ior|-- R: -- x x x x x x
compif incfile1 ; -- i*x u flag ior, there was an error R: -- x x x x x x
ctok FERROR ; -- i*x u flag ior a-addr R: -- x x x x x x
ctok STORE ; -- i*x u flag, save file error R: -- x x x x x x
literal -37 ; File I/O Error
ctok THROW ; -- j*x n R: -- (to be cleared)
incfile1: ; -- i*x u flag, no error, flag false or true? R: -- x x x x x x
compif incfile3 ; -- i*x u, true, there were some chars R: -- x x x x x x
ctok FALSE
literal endq
ctok STORE ; -- i*x R: -- x x x x x x
ctok NUMTIB
ctok STORE ; -- i*x R: -- x x x x x x
literal tickftib
ctok TICK_TIB
ctok STORE ; -- i*x R: -- x x x x x x
ctok FALSE
ctok TO_IN
ctok STORE ; -- i*x R: -- x x x x x x
literal tickftib ; see if first char is the Unicode byte-order marker
ctok C_FETCH ; -- i*x char R: -- x x x x x x
literal 0FEFFH
ctok EQUAL ; -- i*x flag R: -- x x x x x x
compif incfile2 ; -- i*x R: -- x x x x x x
ctok BL
literal tickftib ; -- i*x char c-addr R: -- x x x x x x
ctok C_STORE ; -- i*x R: -- x x x x x x
incfile2:
ctok INTERPRET ; -- j*x
compelse incfileloop
incfile3: ; -- j*x u, chars read (0) R: -- x x x x x x
; Start restoring the input stream
ctok DROP ; -- j*x R: -- x x x x x x
ctok R_FROM
literal endq
ctok STORE ; -- j*x R: -- x x x x x
ctok R_FROM
ctok BLK
ctok STORE ; -- j*x R: -- x x x x
ctok R_FROM
ctok SOURCE_ID
ctok STORE ; -- j*x R: -- x x x
ctok R_FROM
ctok TO_IN
ctok STORE ; -- j*x R: -- x x
ctok R_FROM
ctok NUMTIB
ctok STORE ; -- j*x R: -- x
ctok R_FROM
ctok TICK_TIB
ctok STORE ; -- j*x R: --
ctok UNNEST
fname <INCLUDED> ; i*x c-addr u -- j*x
ctok NEST ; FILE
ctok RO ; -- x1
ctok OPENFILE ; -- x2 ior
ctok QDUP
compif included1 ; file error
ctok FERROR
ctok STORE ; save error for analysis
literal -37
ctok THROW ; throw exception
included1:
ctok DUP ; -- fid fid
ctok TO_R ; -- fid R: -- fid
ctok DOLIT
ctok INCLUDEFILE ; -- fid xt R: -- fid
ctok CATCH ; -- 0|n R: -- fid
ctok R_FROM ; -- 0|n fid R: --
ctok CLOSEFILE ; -- 0|n ior
ctok DROP ; -- 0|n
ctok THROW ; if an error occured, THROW it!
ctok UNNEST
fnamemanque <OPEN-FILE> ; c-addr u x1 -- x2 ior (== 0 | system err)
fw_OPENFILE: ; FILE
ctok NEST
ctok TO_R ; -- c-addr u R: -- x1
ctok CHARS
ctok TUCK ; -- u' c-addr u' R: -- x1
literal zeroBuffer ; -- u' c-addr1 u' c-addr2 R: -- x1
ctok SWAP ; -- u' c-addr1 c-addr2 u' R: -- x1
ctok MOVE ; -- u' R: -- x1
literal zeroBuffer ; -- u' c-addr R: -- x1
ctok OVER ; -- u' c-addr u' R: -- x1
ctok PLUS ; -- u' c-addr' R: -- x1
literal 0 ; -- u' c-addr' 0 R: -- x1
ctok SWAP ; -- u' 0 c-addr' R: -- x1
ctok C_STORE ; -- u' R: --
literal zeroBuffer ; -- u' c-addr R: -- x1
ctok SWAP ; -- c-addr u' R: -- x1
ctok R_FROM ; -- c-addr u' x1 R: --
ctok OPEFILE ; -- x2 ior
ctok UNNEST
zname <OPEFILE> ; c-addr u x1 -- x2 ior (== 0 | system err)
docode
pop eax ; x1
pop ecx ; u
pop edx ; c-addr
add edx,dp ; abs-addr
INVOKE CreateFileW, edx, eax, 0, OFFSET FLAT:secAttrib, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0
push eax ; push resultant handle
cmp eax,INVALID_HANDLE_VALUE
jne openfile1 ; if handle is invalid, we don't branch
INVOKE GetLastError ; get error
push eax ; push error ior
store lastError,eax ; to be consistent with rest of system
next
openfile1:
xor eax,eax
push eax ; success, ior is zero
next
fnamemanque <READ-FILE> ; c|b-addr u1 fileid -- u2 ior
fw_READFILE:
defers
nnamemanque <READ-FILEW> ; c-addr u1 fileid -- u2 ior (== 0 | system err)
fw_READFILEW: ; FILE
ctok NEST
ctok SWAP ; -- c-addr fileid u-chars
ctok TWO_STAR ; -- c-addr fileid u-bytes
ctok SWAP ; -- c-addr u-bytes fileid
ctok READFILEA ; -- u2 ior
ctok SWAP ; -- ior u2
ctok TWO_SLASH ; -- ior u2'
ctok SWAP ; -- u2' ior
ctok UNNEST
nnamemanque <READ-FILEA> ; b-addr u1 fileid -- u2 ior (== 0 | system err)
fw_READFILEA: ; FILE
docode
pop edx ; fileid
pop ecx ; u1
pop eax ; c-addr
add eax,dp ; abs-addr
INVOKE ReadFile, edx, eax, ecx, OFFSET FLAT:numRead, 0
push DWORD PTR numRead ; u2
and eax,eax
jne readfile1 ; result was bool true, so we branch on success
INVOKE GetLastError ; get error
push eax ; push error ior
store lastError,eax ; to be consistent with rest of system
next
readfile1:
xor eax,eax
push eax ; success, ior is zero
next
fnamemanque <READ-LINE> ; c-addr u1 fileid -- u2 flag ior (== 0 | system err)
fw_READLINE: ; FILE
ctok NEST
ctok SWAP ; -- c-addr fileid u1
literal rlbuffsize ; -- c-addr fileid u1 n, let's only allow this many max
ctok MIN ; -- c-addr fileid u1'
literal 0 ; -- c-addr fileid u1' 0
ctok MAX ; -- c-addr fileid u1''
ctok SWAP ; -- c-addr u1 fileid, 0 - rlbuffsize is acceptable
ctok DUP ; -- c-addr u1 fileid fileid
ctok FILESIZEW ; -- c-addr u1 fileid ud2 ior
ctok QDUP ; -- c-addr u1 fileid ud2 ior ior|--
compif rline1 ; -- c-addr u1 fileid ud2 ior, FILE-SIZE failed
ctok TO_R ; -- c-addr u1 fileid ud2 R: -- ior
ctok ROT
ctok DROP ; -- c-addr u1 ud2 R: -- ior
ctok ROT
ctok DROP ; -- c-addr ud2 R: -- ior
ctok ROT
ctok DROP ; -- ud2 R: -- ior
ctok R_FROM ; -- x x ior R: --
ctok EXIT ; -- u2 flag ior, failure indicated by ior, ud2 subs for u2 flag
rline1: ; we have a FILE-SIZE
literal 2
ctok PICK ; -- c-addr u1 fileid ud2 fileid
ctok FILEPOSITIONW ; -- c-addr u1 fileid ud2 ud3 ior
ctok QDUP ; -- c-addr u1 fileid ud2 ud3 ior ior|--
compif rline2 ; -- c-addr u1 fileid ud2 ud3 ior, FILE-POSITION failed
ctok TO_R ; -- c-addr u1 fileid ud2 ud3 R: -- ior
ctok TWO_TO_R ; -- c-addr u1 fileid ud2 R: -- ior ud3
ctok TWO_DROP ; -- c-addr u1 fileid R: -- ior ud3
ctok TWO_DROP ; -- c-addr R: -- ior ud3
ctok DROP ; -- R: -- ior ud3
ctok TWO_R_FROM ; -- ud2 R: -- ior
ctok R_FROM ; -- x x ior R: --
ctok EXIT ; -- ud2 ior, failure indicated by ior, ud2 subs for u2 flag
rline2: ; -- c-addr u1 fileid ud2 ud3, we have file position and size
ctok TWO_DUP ; -- c-addr u1 fileid ud2 ud3 ud3
ctok TWO_TO_R ; -- c-addr u1 fileid ud2 ud3 R: -- ud3
ctok D_EQUAL ; -- c-addr u1 fileid flag, is the file at the end? R: -- ud3
compif rline3 ; -- c-addr u1 fileid, yes R: -- ud3
ctok TWO_R_FROM ; -- c-addr u1 fileid ud3 R: --
ctok TWO_DROP ; -- c-addr u1 fileid
ctok TWO_DROP ; -- c-addr
ctok DROP ; --
ctok FALSE
ctok FALSE
ctok FALSE
ctok EXIT ; -- 0 0 0, proper return if file was exhausted when we started
rline3: ; -- c-addr u1 fileid flag, file not at end yet R: -- ud3
literal rlBuffer ; -- c-addr u1 fileid a-addr R: -- ud3
literal rlbuffsize ; -- c-addr u1 fileid a-addr u2 R: -- ud3
literal 2
ctok PICK ; -- c-addr u1 fileid a-addr u2 fileid R: -- ud3
ctok READFILEW ; -- c-addr u1 fileid u2 ior R: -- ud3
ctok QDUP ; -- c-addr u1 fileid u2 ior ior|-- R: -- ud3
compif rline4 ; -- c-addr u1 fileid u2 ior, error on read R: -- ud3
ctok TO_R ; -- c-addr u1 fileid u2 R: -- ud3 ior
ctok TWO_DROP
ctok TWO_DROP ; -- R: -- ud3 ior
ctok FALSE
ctok FALSE
ctok R_FROM ; -- 0 0 ior R: -- ud3
ctok TWO_R_FROM ; -- 0 0 ior ud3 R: --
ctok TWO_DROP ; -- 0 0 ior
ctok EXIT ; -- 0 0 ior, this looks good on a read error
rline4: ; -- c-addr u1 fileid u2 R: -- ud3
ctok SWAP ; -- c-addr u1 u2 fileid R: -- ud3
ctok TO_R ; -- c-addr u1 u2 R: -- ud3 fileid
literal rlBuffer ; -- c-addr1 u1 u2 c-addr2 R: -- ud3 fileid
ctok SWAP ; -- c-addr1 u1 c-addr2 u2 R: -- ud3 fileid
literal lFeed ; -- c-addr1 u1 c-addr2 u2 char R: -- ud3 fileid
ctok SCAN ; -- c-addr1 u1 c-addr2' u2' R: -- ud3 fileid
ctok DROP ; -- c-addr1 u1 c-addr2' R: -- ud3 fileid
literal rlBuffer ; -- c-addr1 u1 c-addr2' c-a-buff R: -- ud3 fileid
ctok TUCK ; -- c-addr1 u1 c-a-buff c-addr2' c-a-buff R: -- ud3 fileid
ctok MINUS ; -- c-addr1 u1 c-a-buff ubytes R: -- ud3 fileid
ctok S_TO_D
literal 1
ctok CHARS ; dividing since address arithmentic resulted in bytes, not chars
ctok UMSLMOD ; -- c-addr1 u1 c-a-buff umod uchars R: -- ud3 fileid
ctok NIP ; -- c-addr1 u1 c-a-buff uchars R: -- ud3 fileid
ctok ONE_PLUS ; Since SCAN returned the address of the LF,
; our subtraction is one char short of the total read.
ctok TWO_DUP ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars R: -- ud3 fileid
ctok DUP ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars uchars R: -- ud3 fileid
ctok R_FROM ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars uchars fileid R: -- ud3
ctok SWAP ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fileid uchars R: -- ud3
ctok S_TO_D ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fileid ud4 R: -- ud3
ctok TWO_R_FROM ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud4 ud3 R: --
ctok D_PLUS ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5
literal 2
ctok PICK ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5 fid
ctok FILESIZEW ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5 ud6 ior
ctok QDUP ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5 ud6 ior ior|--
compif rlineZZ ; FILE-SIZE failed
ctok TO_R ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5 ud6 R: -- ior
ctok TWO_DROP ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud5 R: -- ior
ctok TWO_DROP ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid R: -- ior
ctok TWO_DROP ; -- c-a1 u1 c-a-buff uchars c-a-buff R: -- ior
ctok TWO_DROP ; -- c-a1 u1 c-a-buff R: -- ior
ctok DROP ; -- x x R: -- ior
ctok R_FROM ; -- x x ior R: --
ctok EXIT ; -- u2 flag ior, failure indicated by ior, ud2 subs for u2 flag
rlineZZ:
ctok UDMIN ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars fid ud'
ctok ROT ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars ud' fid
ctok REPOFILEW ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars ior
ctok QDUP ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars ior|-
compif rline5 ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars ior, we had a reposition err
ctok NIP ; Only the IOR matters here, so we toss three stack items
ctok NIP ; and, leave whatever was below to fill out stack return.
ctok NIP ; -- x x ior, we had a reposition error
ctok EXIT
rline5: ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars R: --
ctok DUP ; we start off assuming all chars will count in the count
ctok TO_R ; -- c-a1 u1 c-a-buff uchars c-a-buff uchars R: -- uchars
ctok ONE_MINUS ; -- c-a1 u1 c-a-buff uchars c-a-buff u4 R: -- uchars
; we want to point *to* the last char, the LF, not *past* it
ctok CHARS ; -- c-a1 u1 c-a-buff uchars c-a-buff u4' R: -- uchars
ctok PLUS ; -- c-a1 u1 c-a-buff uchars c-addr2 R: -- uchars
ctok DUP ; -- v-a1 u1 c-a-buff uchars c-addr2 c-addr2 R: -- uchars
ctok C_FETCH ; -- c-a1 u1 c-a-buff uchars c-addr2 char R: -- uchars
literal lFeed
ctok EQUAL ; -- c-addr1 u1 c-a-buff uchars c-addr2 flag R: -- uchars
compif rline6 ; Last char we read into buffer turns out to be LF
ctok R_FROM ; -- c-addr1 u1 c-a-buff uchars c-addr2 uchars R: --
ctok ONE_MINUS ; -- c-addr1 u1 c-a-buff uchars c-addr2 uchars' R: --
ctok TO_R ; -- c-addr1 u1 c-a-buff uchars c-addr2 R: -- uchars'
literal 1
ctok CHARS ; subtract a char from the returned count
ctok MINUS ; -- c-addr1 u1 c-a-buff uchars c-addr2' R: -- uchars'
ctok C_FETCH ; -- c-addr1 u1 c-a-buff uchars char R: -- uchars'
literal cRet
ctok EQUAL ; -- c-addr1 u1 c-a-buff uchars flag R: -- uchars'
compif rline7 ; There's a CR before the LF
ctok R_FROM
ctok ONE_MINUS ; subtract yet another char from the returned count
ctok TO_R ; -- c-addr1 u1 c-a-buff uchars R: -- uchars''
compelse rline7
rline6: ; -- c-addr1 u1 c-a-buff uchars c-addr2 R: -- uchars'
ctok DROP ; get rid of extra address, we don't check for CR
rline7: ; -- c-addr1 u1 c-a-buff uchars R: -- uchars''
ctok ROT ; -- c-addr1 c-a-buff uchars u1 R: -- uchars''
ctok MIN ; -- c-addr1 c-a-buff u R: -- uchars''
literal 0
ctok MAX ; -- c-addr1 c-a-buff u R: -- uchars''
ctok TO_R
ctok SWAP
ctok R_FROM ; -- c-a-buff c-addr1 u R: -- uchars''
ctok CMOVE ; -- R: -- uchars''
ctok R_FROM
ctok TRUE
literal 0 ; -- u flag ior R: --
ctok UNNEST
fnamemanque <REPOSITION-FILE> ; ud fileid -- ior (== 0 | system err)
fw_REPOFILE: ; FILE
defers
nnamemanque <REPOSITION-FILEW> ; ud-chars fileid -- ior (== 0 | system err)
fw_REPOFILEW: ; FILE
ctok NEST
ctok TO_R ; -- ud-chars R: -- fileid
literal tchar ; -- ud-chars u R: -- fileid
ctok UDSTARU ; -- ud-bytess R: -- fileid
ctok R_FROM ; -- ud-chars fileid R: --
ctok REPOFILEA ; -- ior
ctok UNNEST
nnamemanque <REPOSITION-FILEA> ; ud-bytes fileid -- ior (== 0 | system err)
fw_REPOFILEA: ; FILE
docode
pop edx ; fileid
pop DWORD PTR distMoveHigh ; hi word of dist to move
pop eax ; low
INVOKE SetFilePointer, edx, eax, OFFSET FLAT:distMoveHigh, FILE_BEGIN
cmp eax,-1 ; if -1, must check distMoveHigh
jne repofile1
cmp DWORD PTR distMoveHigh,0 ; if zero, we have an err
jne repofile1 ; not zero is success
INVOKE GetLastError ; get error
push eax ; push error ior
store lastError,eax ; to be consistent with rest of system
next
repofile1:
xor eax,eax
push eax ; success, ior is zero
next
fnamemanque <RESIZE-FILE> ; ud fileid -- ior (== 0 | system err)
fw_RESIZEFILE: ; FILE
defers
nnamemanque <RESIZE-FILEW> ; ud-chars fileid -- ior (== 0 | system err)
fw_RESIZEFILEW: ; FILE
ctok NEST
ctok TO_R ; -- ud-chars R: -- fileid
literal tchar
ctok UDSTARU ; -- ud-bytes R: -- fileid
ctok R_FROM ; -- ud-bytes fileid
ctok RESIZEFILEA ; -- ior
ctok UNNEST
nnamemanque <RESIZE-FILEA> ; ud-bytes fileid -- ior (== 0 | system err)
fw_RESIZEFILEA: ; FILE
ctok NEST
ctok DUP ; -- ud fileid fileid
ctok TO_R ; -- ud fileid R: -- fileid
ctok REPOFILEA ; -- flag R: -- fileid
ctok R_FROM ; -- flag fileid
ctok SWAP ; -- fileid flag
ctok DUP ; -- fileid flag flag
ctok ZEROEQ
compif resizefile1
ctok DROP ; -- fileid
ctok SETEOF ; -- ior
ctok EXIT
resizefile1:
ctok SWAP ; -- ior fileid
ctok DROP ; -- ior
ctok UNNEST ; -- ior
sname <SETEOF> ; fileid -- ior Set end of file at current file pointer
docode
mov eax,[esp]
INVOKE SetEndOfFile, eax
and eax,eax
je seteofend
INVOKE GetLastError
mov [esp],eax
next
seteofend:
xor eax,eax
mov [esp],eax
next
fnamemanque <WRITE-FILE> ; b|c-addr u fileid -- ior (== 0 | system err)
fw_WRITEFILE:
defers
nnamemanque <WRITE-FILEW> ; c-addr u fileid -- ior (== 0 | system err)
fw_WRITEFILEW:
ctok NEST
ctok SWAP ; -- c-addr fileid u-chars
ctok TWO_STAR ; -- c-addr fileid u-bytes
ctok SWAP ; -- c-addr u-bytes fileid
ctok WRITEFILEA ; -- ior
ctok UNNEST
nnamemanque <WRITE-FILEA> ; b-addr u fileid -- ior (== 0 | system err)
fw_WRITEFILEA: ; FILE
docode
pop edx ; fileid
pop ecx ; u1
pop eax ; c-addr
add eax,dp ; abs-addr
INVOKE WriteFile, edx, eax, ecx, OFFSET FLAT:numRead, 0
and eax,eax
jne writefile1 ; result was bool true, so we branch on success
INVOKE GetLastError ; get error
push eax ; push error ior
store lastError,eax ; to be consistent with rest of system
next
writefile1:
xor eax,eax
push eax ; success, ior is zero
next
fnamemanque <R/O> ; -- x
fw_RO: ctok DOCONST ; FILE
dd GENERIC_READ
fnamemanque <R/W> ; -- x
fw_RW: ctok DOCONST ; FILE
dd GENERIC_READ OR GENERIC_WRITE
fnamemanque <W/O> ; -- x
fw_WO: ctok DOCONST ; FILE
dd GENERIC_WRITE
fname <BIN> ; fam1 -- fam2
docode ; FILE
next
;--( BLOCK stuff )
nnamemanque <BLOCK-FILE> ; -- a-addr
fw_BLOCKFILE:
ctok DOCONST
dd blockFile ; holds the file id for active BLOCK file
fname <BLOCK> ; u -- a-addr
ctok NEST
ctok DUP ; -- u u
ctok INVALIDBLOCK ; -- u flag
literal -35 ; invalid block number THROW
ctok AND ; throw if block was invalid
ctok THROW
ctok BLOCKFILE ; -- u a-addr
ctok FETCH ; -- u file-id
ctok ZEROEQ ; -- u flag
literal -37 ; file I/O exception
ctok AND ; so that we either THROW a -37 or a 0 (e.g., continue on)
ctok THROW
literal blockNum ; -- u a-addr
ctok FETCH ; -- u1 u2
ctok OVER ; -- u1 u2 u1
ctok NEQUAL ; -- u flag TRUE if blockBuffer doesn't current hold that block number
compif block2 ; -- u If they are equal, jump ahead and exit
ctok DUP ; -- u u Not equal, get a BUFFER
ctok BUFFER ; -- u a-addr
ctok SWAP ; -- a-addr u
literal blockSize
ctok UMSTAR ; -- a-addr ud
ctok BLOCKFILE
ctok FETCH ; -- a-addr ud file-id
ctok REPOFILEW ; -- a-addr flag
compif block1
literal -35 ; Invalid Block Number
ctok THROW
block1: ; -- a-addr
literal blockSize
ctok BLOCKFILE
ctok FETCH ; -- a-addr ud file-id
ctok READFILEW ; -- numread ior
ctok SWAP ; -- ior numread
literal blockSize ; -- ior numread n
ctok NEQUAL ; -- ior flag
ctok OR ; -- flag
compif block3
literal -33 ; BLOCK read error
ctok THROW
block2: ; -- u we're already there
ctok DROP ; --
block3:
literal blockBuffer ; -- a-addr
ctok UNNEST
nname <BLOCKNUM>
ctok DOCONST
dd blockNum
nname <UPDATED>
ctok DOCONST
dd updated
fname <BUFFER> ; u -- a-addr
ctok NEST
literal blockNum
ctok FETCH ; -- u1 u2
ctok OVER ; -- u1 u2 u1
ctok NEQUAL ; -- u flag TRUE if blockBuffer doesn't current hold that block number
compif buffer2
literal updated
ctok FETCH ; -- u flag Is BLOCK we're going to replace an UPDATEd BLOCK?
compif buffer1
ctok SAVEBUFFERS ; -- u Yes, save buffer(s), mark not updated
buffer1:
literal blockNum
ctok STORE ; -- Renumber buffer
compelse buffer3
buffer2: ; -- u Buffer was already present
ctok DROP ; --
buffer3:
literal blockBuffer ; -- a-addr
ctok UNNEST
fnamemanque <EMPTY-BUFFERS> ; --
fw_EMPTYBUFFERS: ; BLOCK EXT
ctok NEST
ctok FALSE
literal updated
ctok STORE
ctok TRUE
literal blockNum
ctok STORE
literal blockBuffer
literal blockSize
ctok BL
ctok FILL
ctok UNNEST
fnamemanque <SAVE-BUFFERS> ; --
fw_SAVEBUFFERS: ; BLOCK
ctok NEST
literal updated
ctok FETCH ; -- flag
compif savebuf7 ; 0 == not updated, leave
literal blockNum
ctok FETCH ; -- n
ctok TRUE
ctok NEQUAL ; -- flag
compif savebuf7 ; BLOCK number of TRUE == no block, leave
ctok BLOCKFILE
ctok FETCH ; -- file-id
ctok DUP ; -- file-id file-id
ctok ZEROEQ ; -- file-id flag
compif savebuf4 ; 0 == no BLOCK file
literal -37 ; file I/O exception
ctok THROW
savebuf4: ; yes, there is a BLOCK file handle in the controlling blockFile variable
literal blockNum ; -- file-id u
ctok FETCH
literal blockSize ; -- file-id u'
ctok UMSTAR ; -- file-id ud
literal 2
ctok PICK ; -- file-id ud file-id
ctok REPOFILEW ; -- file-id ior
compif savebuf5
literal -35 ; Invalid Block Number
ctok THROW
savebuf5:
literal blockBuffer ; -- file-id c-addr
literal blockSize ; -- file-id c-addr u
ctok ROT ; -- file-id c-addr u file-id
ctok WRITEFILEW ; -- ior
compif savebuf6
literal -34 ; BLOCK write error
ctok THROW
savebuf6:
ctok FALSE ; -- 0
literal updated
ctok STORE ; --
compelse savebuf7
savebuf7:
ctok UNNEST
fname <FLUSH> ; --
ctok NEST ; BLOCK
ctok SAVEBUFFERS
ctok EMPTYBUFFERS
ctok UNNEST
fname <UPDATE> ; --
ctok NEST ; BLOCK
ctok TRUE
literal updated
ctok STORE
ctok UNNEST
fname <SCR> ; -- a-addr
ctok DOCONST ; BLOCK EXT
dd var_scr
fname <LIST> ; u --
ctok NEST ; BLOCK EXT
ctok DUP
ctok SCR
ctok STORE ; -- u
ctok PAGE
ctok DOKDOTQUOTE
dd listMsg1
ctok DUP ; -- u u
ctok DOT ; -- u
literal 28
literal 0
ctok AT_XY ; center justify
ctok DOKDOTQUOTE
dd listMsg2
ctok BLOCKFILE ; -- u a-addr
ctok FETCH ; -- u1 fid
ctok DOT ; -- u1
ctok BLOCK ; -- a-addr
literal 16
literal 0
compdo list2
list1: ctok CR ; -- a-addr
ctok I ; -- a-addr n
ctok DUP ; -- a-addr n n
literal 2
ctok DOT_R ; -- a-addr n
ctok SPACE
literal 64
ctok CHARS
ctok STAR ; -- a-addr n'
ctok OVER ; -- a-addr n' a-addr
ctok PLUS ; -- a-addr1 a-addr2
literal 64
ctok TYPE ; -- a-addr1
ctok I
literal 2
ctok DOT_R ; -- a-addr
comploop list1
list2: ctok DROP ; --
ctok UNNEST
fname <LOAD> ; i*x u -- j*x
ctok NEST ; BLOCK
ctok QDUP
ctok ZEROEQ
compif load1
ctok okPrompt
ctok QUIT ; Quit if Block number is 0
load1: ctok BLK ; Save input on return stack
ctok FETCH
ctok TO_R
ctok TIB
ctok TO_R
ctok NUMTIB
ctok FETCH
ctok TO_R
ctok TO_IN
ctok FETCH
ctok TO_R
ctok SOURCE_ID
ctok FETCH
ctok TO_R
literal endq
ctok FETCH
ctok TO_R
ctok FALSE
literal endq
ctok STORE
ctok BLK
ctok STORE
ctok FALSE
ctok SOURCE_ID
ctok STORE
ctok FALSE
ctok TO_IN
ctok STORE
ctok INTERPRET
ctok R_FROM ; Restore input spec
literal endq
ctok STORE
ctok R_FROM
ctok SOURCE_ID
ctok STORE
ctok R_FROM
ctok TO_IN
ctok STORE
ctok R_FROM
ctok NUMTIB
ctok STORE
ctok R_FROM
ctok TICK_TIB
ctok STORE
ctok R_FROM
ctok BLK
ctok STORE ; -- j*x R: --
ctok UNNEST
fname <THRU> ; i*x u1 u2 -- j*x
ctok NEST ; BLOCK EXT
ctok ONE_PLUS
ctok SWAP
compqdo thru2
thru1: ctok I
ctok LOAD
comploop thru1
thru2: ctok UNNEST
zname <INVALIDBLOCK> ; u -- flag
ctok NEST
ctok ONE_PLUS ; we're calculating the bytes needed to complete the BLOCK.
literal blockSize ; -- u1 u2
ctok UMSTAR ; -- ud
ctok BLOCKFILE ; -- ud a-addr
ctok FETCH ; -- ud file-id
ctok FILESIZEW ; -- ud1 ud2 ior
ctok ZERONE ; -- ud1 ud2 flag
literal -37 ; file I/O exception
ctok AND ; so that we either THROW a -37 or a 0 (e.g., continue on)
ctok THROW
ctok TWO_SWAP ; -- ud2 ud1
ctok UD_LESS ; block requested greater than blocks in file? ( ud2 < ud1 ) if so, invalid block
ctok UNNEST
; END of jx4files.a